(*
     camlflickr
     Copyright (C) 2008  Zachary R. Anderson (zanderso@gmail.com)
 
     This program is free software; you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
     the Free Software Foundation; either version 2 of the License, or
     (at your option) any later version.
 
     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.
 
     You should have received a copy of the GNU General Public License along
     with this program; if not, write to the Free Software Foundation, Inc.,
     51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)

module X = Xml
module H = Http_client
module HC = Http_client.Convenience

let (|>) (a : 'a) (f : 'a -> 'b) : 'b = f a

module Xmlutil = struct

    type xmlSelect =
        | A of string * string
        | C of string * int
        | T

    exception XmlExtractionFailure of string
    exception XmlMalformedSelector of string

    let stringToSelect (ss : string) : xmlSelect list =
        Str.split (Str.regexp_string ".") ss
        |> List.map (fun s ->
            if s = "text" then T else try
                let lb = String.index s '[' in
                let rb = String.rindex s ']' in
                if rb < lb then raise(XmlMalformedSelector s) else
                let sel = String.sub s (lb + 1) (rb - lb - 1) in
                let base = String.sub s 0 lb in
                try
                    C(base,int_of_string sel)
                with Failure _ -> A(base,sel)
            with Not_found -> raise(XmlMalformedSelector s))

    let rec getXml (sl : xmlSelect list) (xml : X.xml) : X.xml =
        try
            match sl with
            | [C(n, _)] when n = X.tag xml -> xml
            | C(n,i) :: rst when n = X.tag xml ->
                getXml rst (List.nth (X.children xml) i)
            | _ -> raise(XmlExtractionFailure (X.to_string_fmt xml))
        with _ -> raise(XmlExtractionFailure (X.to_string_fmt xml))

    let rec getXmlList (sl : xmlSelect list) (xml : X.xml) : X.xml list =
        try
            match sl with
            | [C(n, _)] when n = X.tag xml -> X.children xml
            | C(n, i) :: rst when n = X.tag xml ->
                getXmlList rst (List.nth (X.children xml) i)
            | _ -> raise(XmlExtractionFailure (X.to_string_fmt xml))
        with _ -> raise(XmlExtractionFailure (X.to_string_fmt xml))

    let rec getXmlVal (sl : xmlSelect list) (xml : X.xml) : string =
        try
            match sl with
            | T :: _ -> X.pcdata xml
            | A(n,a) :: _ when n = X.tag xml -> X.attrib xml a
            | C(n,i) :: rst when n = X.tag xml ->
                getXmlVal rst (List.nth (X.children xml) i)
            | _ -> raise(XmlExtractionFailure (X.to_string_fmt xml))
        with _ -> raise(XmlExtractionFailure (X.to_string_fmt xml))


    let getXml (ss : string) (xml : X.xml) : X.xml =
        getXml (stringToSelect ss) xml

    let getXmlList (ss : string) (xml : X.xml) : X.xml list =
        getXmlList (stringToSelect ss) xml

    let getXmlVal (ss : string) (xml : X.xml) : string =
        getXmlVal (stringToSelect ss) xml

end

open Xmlutil

let flickrhost = "http://api.flickr.com"
let flickrREST = "/services/rest/?"
let flickrAuth = "/services/auth/?"
let flickrUpload = "/services/upload/?"
let flickrReplace = "/services/replace/?"

type callType =
    | REST
    | Auth
    | Upload of string
    | Replace of string

(* TODO: add types for the various responses? *)
type user =
    {
        mutable nsid : string;
        mutable username : string;
        mutable fullname : string;
    }
let xmlToUser (userxml : X.xml) : user =
    {nsid = getXmlVal "user[nsid]" userxml;
     username = getXmlVal "user[username]" userxml;
     fullname = getXmlVal "user[fullname]" userxml;}

type photo =
    {
        id : string;
        owner : string;
        secret : string;
        server : string;
        farm : string;
        title : string;
        ispublic : string;
        isfriend : string;
        isfamily : string;
    }
let xmlToPhoto (photoxml : X.xml) : photo =
    let phGetVal s = getXmlVal ("photo["^s^"]") photoxml in
    {id = phGetVal "id";
     owner = phGetVal "owner";
     secret = phGetVal "secret";
     server = phGetVal "server";
     farm =  phGetVal "farm";
     title = phGetVal "title";
     ispublic = phGetVal "ispublic";
     isfriend = phGetVal "isfriend";
     isfamily = phGetVal "isfamily";}
     

let xmlToAuth (authxml : X.xml) : string * string * user =
    getXmlVal "rsp[0].auth[0].token[0].text" authxml,
    getXmlVal "rsp[0].auth[1].perms[0].text" authxml,
    xmlToUser(getXml "rsp[0].auth[2].user[0]" authxml)

(* Assumes file exists. Reads a file into a string *)
let input_file (fname : string) : string =
    let ic = open_in fname in
    let len = in_channel_length ic in
    let s = String.create len in
    really_input ic s 0 len;
    close_in ic;
    s

(* downloads url into file at path *)
let download_file (path : string) (url : string) : unit =
    let r = HC.http_get url in
    let outf = open_out path in
    output_string outf r;
    close_out outf

(* downloads photo ph into directory dir. If url is "", construct the url from
   ph and sz. If url is specified, sz is ignored, and ph is used only to
   construct the name of the target file. *)
let downloadPhoto (dir : string) ?(url : string = "") ?(sz : string = "")
                  (ph : photo) : unit =
    let url, fname =
        if url <> "" then
            url, ph.id^"_"^ph.secret^".jpg"
        else match sz with
        | "" ->
            "http://farm"^ph.farm^".static.flickr.com/"^
                ph.server^"/"^ph.id^"_"^ph.secret^".jpg",
            ph.id^"_"^ph.secret^".jpg"
        | _ ->
            "http://farm"^ph.farm^".static.flickr.com/"^
                ph.server^"/"^ph.id^"_"^ph.secret^"_"^sz^".jpg",
            ph.id^"_"^ph.secret^"_"^sz^".jpg"
    in
    download_file (dir^"/"^fname) url

(* Need this to hide the token instance variable below. *)
class type flickrClassType = object
    method restCall : string -> (string * string) list -> string
    method restUnauthCall : string -> (string * string) list -> string
    method authCall : string -> (string * string) list -> string
    method uploadCall : string -> (string * string) list -> string
    method replaceCall : string -> (string * string) list -> string
    method getTokenPartOne : (string -> unit) -> string -> string * string
    method getTokenPartTwo : string -> string -> string
end

class flickrClass' (api_key : string) (api_secret : string) = object(self)

    val mutable token = ""

    method private calcApiSig (ssl : (string * string) list) : string =
        ssl
        |> List.sort (fun (m1,_) (m2,_) -> String.compare m1 m2)
        |> List.fold_left (fun sigstr (m,a) -> sigstr^m^a) api_secret
        |> Digest.string
        |> Digest.to_hex

    (* Http_client can't do multipart POST,
       so we have to hack it up ourselves. *)
    method private doUpload (url : string) (fname : string)
                            (args : (string * string) list)
                            : string
        =
        let call = new H.post_call in
        let pipe = new H.pipeline in
        let headers = call#request_header `Base in
        let body = call#request_body in
        call#set_request_uri url;
        let boundary = Digest.to_hex(Digest.string api_key) in
        headers#set_fields 
            [("Content-Type","multipart/form-data; boundary="^boundary);
             ("Host","api.flickr.com");];
        let file = input_file fname in
        let data =
            List.fold_left (fun d (n, a) -> d^
                "Content-Disposition: form-data; name=\""^n^"\"\r\n\r\n"^
                a^"\r\n"^
                "--"^boundary^"\r\n") ("--"^boundary^"\r\n") args 
        in
        let data = data^
            "Content-Disposition: form-data; name=\"photo\";"^
                " filename=\""^fname^"\"\r\n"^
            "Content-Type: image/jpeg\r\n\r\n"^
            file^"\r\n"^
            "--"^boundary^"--\r\n"
        in
        body#set_value data;
        call#set_request_body body;
        let len = string_of_int (String.length data) in
        headers#update_field "Content-length" len;
        call#set_request_header headers;
        pipe#add call;
        pipe#run ();
        call#response_body#value

    method private makeApiCall ?(typ : callType = REST) (meth : string)
                                (args : (string * string) list)
                               : string
        =
        let normalCall url =
            args
            |> List.append [("method",meth);("api_key",api_key)]
            |> (fun sl -> ("api_sig",self#calcApiSig sl)::sl)
            |> HC.http_post url
        in
        let uploadCall url fname =
            let args = args
                |> List.append ["api_key",api_key;"auth_token",token]
                |> (fun sl -> ("api_sig",self#calcApiSig sl)::sl)
            in
            self#doUpload url fname args
        in
        match typ with
        | REST -> normalCall (flickrhost^flickrREST)
        | Auth -> normalCall (flickrhost^flickrAuth)
        | Upload fname -> uploadCall (flickrhost^flickrUpload) fname
        | Replace fname -> uploadCall (flickrhost^flickrReplace) fname

    method restCall meth args =
        self#makeApiCall meth (("auth_token",token)::args)
    method restUnauthCall meth args = self#makeApiCall meth args
    method authCall meth args = self#makeApiCall ~typ:Auth meth args
    method uploadCall fname args =
        self#makeApiCall ~typ:(Upload fname) "" args
    method replaceCall fname args =
        self#makeApiCall ~typ:(Replace fname) "" args

    method private makeLoginUrl (perms : string) (frob : string)
                                : string
        =
        [("api_key",api_key);("perms",perms);("frob",frob)]
        |> (fun sl -> ("api_sig",self#calcApiSig sl)::sl)
        |> List.fold_left (fun url (m,a) -> url^m^"="^a^"&")
           (flickrhost^flickrAuth)

    method private validateFrob (callback : string -> unit)
                                (frob : string) (perms : string)
                                : unit
        =
        let url = self#makeLoginUrl perms frob in
        callback url

    method private getFrob (callback : string -> unit)
                           (perms : string)
                           : string * string
        =
        let frobstr =  self#restUnauthCall "flickr.auth.getFrob"
            ["perms",perms]
        in
        let frobxml = X.parse_string frobstr in
        try
            let frob = getXmlVal "rsp[0].frob[0].text" frobxml in
            self#validateFrob callback frob perms;
            frob, ""
        with XmlExtractionFailure _ -> "", ""

    method private getCachedToken () : string option =
        try
            let authfile = (Unix.getenv "HOME")^"/.flickr/"^api_key^"/auth.xml"
            in
            if not(Sys.file_exists authfile) then None else
            Some(input_file authfile)
        with Not_found -> None

    method private putCachedToken (auth_str : string) : unit =
        try
            let flickrdir = (Unix.getenv "HOME")^"/.flickr" in
            if not(Sys.file_exists flickrdir) then
                Unix.mkdir flickrdir 0o755;
            let authdir = flickrdir^"/"^api_key in
            if not(Sys.file_exists authdir) then
                Unix.mkdir authdir 0o755;
            let outf = open_out (authdir^"/auth.xml") in
            output_string outf auth_str;
            close_out outf
        with Not_found -> ()

    method private sufficientPerms (have : string) (want : string) : bool =
        match want, have with
        | "read", ("write" | "delete")
        | "write", "delete" -> false
        | _ -> true

    method getTokenPartOne (callback : string -> unit)
                           (perms : string)
                           : string * string
        =
        match self#getCachedToken () with
        | Some tokenstr -> begin
            let ctok, cperm, cuser = xmlToAuth (X.parse_string tokenstr) in
            if self#sufficientPerms cperm perms then
                let ctokenstr = self#restUnauthCall "flickr.auth.checkToken"
                    ["auth_token", ctok]
                in
                ignore(xmlToAuth (X.parse_string ctokenstr));
                "", ctok
            else self#getFrob callback perms
        end
        | None -> self#getFrob callback perms


    method getTokenPartTwo (tok : string) (frob : string) : string =
        if tok <> "" then begin token <- tok; tok end else
        let tokenstr = self#restUnauthCall "flickr.auth.getToken"
            ["frob",frob;"perms","read"]
        in
        self#putCachedToken tokenstr;
        let tok, perms, user = xmlToAuth (X.parse_string tokenstr) in
        token <- tok;
        tok

end

class flickrClass (api_key : string) (api_secret : string) =
    (flickrClass' api_key api_secret : flickrClassType)

